CD Actual 44/PC Actual CD 44.iso/Linux/Cygwin/full.exe/Disk1/data1.cab/Tools/share/tcl8.0/opt0.1/optparse.tcl

Text File | 1998-12-04 | 32.6 KB | 1,095 lines

# optparse.tcl --
#
#       (Private) option parsing package
#
#       This might be documented and exported in 8.1
#       and some function hopefully moved to the C core for
#       efficiency, if there is enough demand. (mail! ;-)
#
#  Author:    Laurent Demailly  - [e-mail] - [e-mail]
#
#  Credits:
#             this is a complete 'over kill' rewrite by me, from a version
#             written initially with Brent Welch, itself initially
#             based on work with Steve Uhler. Thanks them !
#
# SCCS: @(#) optparse.tcl 1.13 97/08/21 11:50:42

package provide opt 0.2

namespace eval ::tcl {

    # Exported APIs
    namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \
             OptProc OptProcArgGiven OptParse \
             Lassign Lvarpop Lvarset Lvarincr Lfirst \
             SetMax SetMin


#################  Example of use / 'user documentation'  ###################

    proc OptCreateTestProc {} {

    # Defines ::tcl::OptParseTest as a test proc with parsed arguments
    # (can't be defined before the code below is loaded (before "OptProc"))

    # Every OptProc give usage information on "procname -help".
    # Try "tcl::OptParseTest -help" and "tcl::OptParseTest -a" and
    # then other arguments.
    #
    # example of 'valid' call:
    # ::tcl::OptParseTest save -4 -pr 23 -libsok SybTcl\
    #        -nostatics false ch1
    OptProc OptParseTest {
            {subcommand -choice {save print} "sub command"}
            {arg1 3 "some number"}
            {-aflag}
            {-intflag      7}
            {-weirdflag                    "help string"}
            {-noStatics                    "Not ok to load static packages"}
            {-nestedloading1 true           "OK to load into nested slaves"}
            {-nestedloading2 -boolean true "OK to load into nested slaves"}
            {-libsOK        -choice {Tk SybTcl}
                              "List of packages that can be loaded"}
            {-precision     -int 12        "Number of digits of precision"}
            {-intval        7               "An integer"}
            {-scale         -float 1.0     "Scale factor"}
            {-zoom          1.0             "Zoom factor"}
            {-arbitrary     foobar          "Arbitrary string"}
            {-random        -string 12   "Random string"}
            {-listval       -list {}       "List value"}
            {-blahflag       -blah abc       "Funny type"}
        {arg2 -boolean "a boolean"}
        {arg3 -choice "ch1 ch2"}
        {?optarg? -list {} "optional argument"}
        } {
        foreach v [info locals] {
        puts stderr [format "%14s : %s" $v [set $v]]
        }
    }
    }

###################  No User serviceable part below ! ###############
# You should really not look any further :
# The following is private unexported undocumented unblessed... code
# time to hit "q" ;-) !

# Hmmm... ok, you really want to know ?

# You've been warned... Here it is...

    # Array storing the parsed descriptions
    variable OptDesc;
    array set OptDesc {};
    # Next potentially free key id (numeric)
    variable OptDescN 0;

# Inside algorithm/mechanism description:
# (not for the faint hearted ;-)
#
# The argument description is parsed into a "program tree"
# It is called a "program" because it is the program used by
# the state machine interpreter that use that program to
# actually parse the arguments at run time.
#
# The general structure of a "program" is
# notation (pseudo bnf like)
#    name :== definition        defines "name" as being "definition"
#    { x y z }                  means list of x, y, and z
#    x*                         means x repeated 0 or more time
#    x+                         means "x x*"
#    x?                         means optionally x
#    x | y                      means x or y
#    "cccc"                     means the literal string
#
#    program        :== { programCounter programStep* }
#
#    programStep    :== program | singleStep
#
#    programCounter :== {"P" integer+ }
#
#    singleStep     :== { instruction parameters* }
#
#    instruction    :== single element list
#
# (the difference between singleStep and program is that \
#   llength [Lfirst $program] >= 2
# while
#   llength [Lfirst $singleStep] == 1
# )
#
# And for this application:
#
#    singleStep     :== { instruction varname {hasBeenSet currentValue} type
#                         typeArgs help }
#    instruction    :== "flags" | "value"
#    type           :== knowType | anyword
#    knowType       :== "string" | "int" | "boolean" | "boolflag" | "float"
#                       | "choice"
#
# for type "choice" typeArgs is a list of possible choices, the first one
# is the default value. for all other types the typeArgs is the default value
#
# a "boolflag" is the type for a flag whose presence or absence, without
# additional arguments means respectively true or false (default flag type).
#
# programCounter is the index in the list of the currently processed
# programStep (thus starting at 1 (0 is {"P" prgCounterValue}).
# If it is a list it points toward each currently selected programStep.
# (like for "flags", as they are optional, form a set and programStep).

# Performance/Implementation issues
# ---------------------------------
# We use tcl lists instead of arrays because with tcl8.0
# they should start to be much faster.
# But this code use a lot of helper procs (like Lvarset)
# which are quite slow and would be helpfully optimized
# for instance by being written in C. Also our struture
# is complex and there is maybe some places where the
# string rep might be calculated at great exense. to be checked.

#
# Parse a given description and saves it here under the given key
# generate a unused keyid if not given
#
proc ::tcl::OptKeyRegister {desc {key ""}} {
    variable OptDesc;
    variable OptDescN;
    if {[string compare $key ""] == 0} {
        # in case a key given to us as a parameter was a number
        while {[info exists OptDesc($OptDescN)]} {incr OptDescN}
        set key $OptDescN;
        incr OptDescN;
    }
    # program counter
    set program [list [list "P" 1]];

    # are we processing flags (which makes a single program step)
    set inflags 0;

    set state {};

    # flag used to detect that we just have a single (flags set) subprogram.
    set empty 1;

    foreach item $desc {
    if {$state == "args"} {
        # more items after 'args'...
        return -code error "'args' special argument must be the last one";
    }
        set res [OptNormalizeOne $item];
        set state [Lfirst $res];
        if {$inflags} {
            if {$state == "flags"} {
        # add to 'subprogram'
                lappend flagsprg $res;
            } else {
                # put in the flags
                # structure for flag programs items is a list of
                # {subprgcounter {prg flag 1} {prg flag 2} {...}}
                lappend program $flagsprg;
                # put the other regular stuff
                lappend program $res;
        set inflags 0;
        set empty 0;
            }
        } else {
           if {$state == "flags"} {
               set inflags 1;
               # sub program counter + first sub program
               set flagsprg [list [list "P" 1] $res];
           } else {
               lappend program $res;
               set empty 0;
           }
       }
   }
   if {$inflags} {
       if {$empty} {
       # We just have the subprogram, optimize and remove
       # unneeded level:
       set program $flagsprg;
       } else {
       lappend program $flagsprg;
       }
   }

   set OptDesc($key) $program;

   return $key;
}

#
# Free the storage for that given key
#
proc ::tcl::OptKeyDelete {key} {
    variable OptDesc;
    unset OptDesc($key);
}

    # Get the parsed description stored under the given key.
    proc OptKeyGetDesc {descKey} {
        variable OptDesc;
        if {![info exists OptDesc($descKey)]} {
            return -code error "Unknown option description key \"$descKey\"";
        }
        set OptDesc($descKey);
    }

# Parse entry point for ppl who don't want to register with a key,
# for instance because the description changes dynamically.
#  (otherwise one should really use OptKeyRegister once + OptKeyParse
#   as it is way faster or simply OptProc which does it all)
# Assign a temporary key, call OptKeyParse and then free the storage
proc ::tcl::OptParse {desc arglist} {
    set tempkey [OptKeyRegister $desc];
    set ret [catch {uplevel [list ::tcl::OptKeyParse $tempkey $arglist]} res];
    OptKeyDelete $tempkey;
    return -code $ret $res;
}

# Helper function, replacement for proc that both
# register the description under a key which is the name of the proc
# (and thus unique to that code)
# and add a first line to the code to call the OptKeyParse proc
# Stores the list of variables that have been actually given by the user
# (the other will be sets to their default value)
# into local variable named "Args".
proc ::tcl::OptProc {name desc body} {
    set namespace [uplevel namespace current];
    if {   ([string match $name "::*"])
        || ([string compare $namespace "::"]==0)} {
        # absolute name or global namespace, name is the key
        set key $name;
    } else {
        # we are relative to some non top level namespace:
        set key "${namespace}::${name}";
    }
    OptKeyRegister $desc $key;
    uplevel [list proc $name args "set Args \[::tcl::OptKeyParse $key \$args\]\n$body"];
    return $key;
}
# Check that a argument has been given
# assumes that "OptProc" has been used as it will check in "Args" list
proc ::tcl::OptProcArgGiven {argname} {
    upvar Args alist;
    expr {[lsearch $alist $argname] >=0}
}

    #######
    # Programs/Descriptions manipulation

    # Return the instruction word/list of a given step/(sub)program
    proc OptInstr {lst} {
    Lfirst $lst;
    }
    # Is a (sub) program or a plain instruction ?
    proc OptIsPrg {lst} {
    expr {[llength [OptInstr $lst]]>=2}
    }
    # Is this instruction a program counter or a real instr
    proc OptIsCounter {item} {
    expr {[Lfirst $item]=="P"}
    }
    # Current program counter (2nd word of first word)
    proc OptGetPrgCounter {lst} {
    Lget $lst {0 1}
    }
    # Current program counter (2nd word of first word)
    proc OptSetPrgCounter {lstName newValue} {
    upvar $lstName lst;
    set lst [lreplace $lst 0 0 [concat "P" $newValue]];
    }
    # returns a list of currently selected items.
    proc OptSelection {lst} {
    set res {};
    foreach idx [lrange [Lfirst $lst] 1 end] {
        lappend res [Lget $lst $idx];
    }
    return $res;
    }

    # Advance to next description
    proc OptNextDesc {descName} {
        uplevel [list Lvarincr $descName {0 1}];
    }

    # Get the current description, eventually descend
    proc OptCurDesc {descriptions} {
        lindex $descriptions [OptGetPrgCounter $descriptions];
    }
    # get the current description, eventually descend
    # through sub programs as needed.
    proc OptCurDescFinal {descriptions} {
        set item [OptCurDesc $descriptions];
    # Descend untill we get the actual item and not a sub program
        while {[OptIsPrg $item]} {
            set item [OptCurDesc $item];
        }
    return $item;
    }
    # Current final instruction adress
    proc OptCurAddr {descriptions {start {}}} {
    set adress [OptGetPrgCounter $descriptions];
    lappend start $adress;
    set item [lindex $descriptions $adress];
    if {[OptIsPrg $item]} {
        return [OptCurAddr $item $start];
    } else {
        return $start;
    }
    }
    # Set the value field of the current instruction
    proc OptCurSetValue {descriptionsName value} {
    upvar $descriptionsName descriptions
    # get the current item full adress
        set adress [OptCurAddr $descriptions];
    # use the 3th field of the item  (see OptValue / OptNewInst)
    lappend adress 2
    Lvarset descriptions $adress [list 1 $value];
    #                                  ^hasBeenSet flag
    }

    # empty state means done/paste the end of the program
    proc OptState {item} {
        Lfirst $item
    }

    # current state
    proc OptCurState {descriptions} {
        OptState [OptCurDesc $descriptions];
    }

    #######
    # Arguments manipulation

    # Returns the argument that has to be processed now
    proc OptCurrentArg {lst} {
        Lfirst $lst;
    }
    # Advance to next argument
    proc OptNextArg {argsName} {
        uplevel [list Lvarpop $argsName];
    }
    #######





    # Loop over all descriptions, calling OptDoOne which will
    # eventually eat all the arguments.
    proc OptDoAll {descriptionsName argumentsName} {
    upvar $descriptionsName descriptions
    upvar $argumentsName arguments;
#    puts "entered DoAll";
    # Nb: the places where "state" can be set are tricky to figure
    #     because DoOne sets the state to flagsValue and return -continue
    #     when needed...
    set state [OptCurState $descriptions];
    # We'll exit the loop in "OptDoOne" or when state is empty.
        while 1 {
        set curitem [OptCurDesc $descriptions];
        # Do subprograms if needed, call ourselves on the sub branch
        while {[OptIsPrg $curitem]} {
        OptDoAll curitem arguments
#        puts "done DoAll sub";
        # Insert back the results in current tree;
        Lvarset1nc descriptions [OptGetPrgCounter $descriptions]\
            $curitem;
        OptNextDesc descriptions;
        set curitem [OptCurDesc $descriptions];
                set state [OptCurState $descriptions];
        }
#           puts "state = \"$state\" - arguments=($arguments)";
        if {[Lempty $state]} {
        # Nothing left to do, we are done in this branch:
        break;
        }
        # The following statement can make us terminate/continue
        # as it use return -code {break, continue, return and error}
        # codes
            OptDoOne descriptions state arguments;
        # If we are here, no special return code where issued,
        # we'll step to next instruction :
#           puts "new state  = \"$state\"";
        OptNextDesc descriptions;
        set state [OptCurState $descriptions];
        }
        if  {![Lempty $arguments]} {
            return -code error [OptTooManyArgs $descriptions $arguments];
        }
    }

    # Process one step for the state machine,
    # eventually consuming the current argument.
    proc OptDoOne {descriptionsName stateName argumentsName} {
        upvar $argumentsName arguments;
        upvar $descriptionsName descriptions;
    upvar $stateName state;

    # the special state/instruction "args" eats all
    # the remaining args (if any)
    if {($state == "args")} {
        OptCurSetValue descriptions $arguments;
        set arguments {};
#            puts "breaking out ('args' state: consuming every reminding args)"
        return -code break;
    }

    if {[Lempty $arguments]} {
        if {$state == "flags"} {
        # no argument and no flags : we're done
#                puts "returning to previous (sub)prg (no more args)";
        return -code return;
        } elseif {$state == "optValue"} {
        set state next; # not used, for debug only
        # go to next state
        return ;
        } else {
        return -code error [OptMissingValue $descriptions];
        }
    } else {
        set arg [OptCurrentArg $arguments];
    }

        switch $state {
            flags {
                # A non-dash argument terminates the options, as does --

                # Still a flag ?
                if {![OptIsFlag $arg]} {
                    # don't consume the argument, return to previous prg
                    return -code return;
                }
                # consume the flag
                OptNextArg arguments;
                if {[string compare "--" $arg] == 0} {
                    # return from 'flags' state
                    return -code return;
                }

                set hits [OptHits descriptions $arg];
                if {$hits > 1} {
                    return -code error [OptAmbigous $descriptions $arg]
                } elseif {$hits == 0} {
                    return -code error [OptFlagUsage $descriptions $arg]
                }
        set item [OptCurDesc $descriptions];
                if {[OptNeedValue $item]} {
            # we need a value, next state is
            set state flagValue;
                } else {
                    OptCurSetValue descriptions 1;
                }
        # continue
        return -code continue;
            }
        flagValue -
        value {
        set item [OptCurDesc $descriptions];
                # Test the values against their required type
        if [catch {OptCheckType $arg\
            [OptType $item] [OptTypeArgs $item]} val] {
            return -code error [OptBadValue $item $arg $val]
        }
                # consume the value
                OptNextArg arguments;
        # set the value
        OptCurSetValue descriptions $val;
        # go to next state
        if {$state == "flagValue"} {
            set state flags
            return -code continue;
        } else {
            set state next; # not used, for debug only
            return ; # will go on next step
        }
        }
        optValue {
        set item [OptCurDesc $descriptions];
                # Test the values against their required type
        if ![catch {OptCheckType $arg\
            [OptType $item] [OptTypeArgs $item]} val] {
            # right type, so :
            # consume the value
            OptNextArg arguments;
            # set the value
            OptCurSetValue descriptions $val;
        }
        # go to next state
        set state next; # not used, for debug only
        return ; # will go on next step
        }
        }
    # If we reach this point: an unknown
    # state as been entered !
    return -code error "Bug! unknown state in DoOne \"$state\"\
        (prg counter [OptGetPrgCounter $descriptions]:\
            [OptCurDesc $descriptions])";
    }

# Parse the options given the key to previously registered description
# and arguments list
proc ::tcl::OptKeyParse {descKey arglist} {

    set desc [OptKeyGetDesc $descKey];

    # make sure -help always give usage
    if {[string compare "-help" [string tolower $arglist]] == 0} {
    return -code error [OptError "Usage information:" $desc 1];
    }

    OptDoAll desc arglist;

    # Analyse the result
    # Walk through the tree:
    OptTreeVars $desc "#[expr [info level]-1]" ;
}

    # determine string length for nice tabulated output
    proc OptTreeVars {desc level {vnamesLst {}}} {
    foreach item $desc {
        if {[OptIsCounter $item]} continue;
        if {[OptIsPrg $item]} {
        set vnamesLst [OptTreeVars $item $level $vnamesLst];
        } else {
        set vname [OptVarName $item];
        upvar $level $vname var
        if {[OptHasBeenSet $item]} {
#            puts "adding $vname"
            # lets use the input name for the returned list
            # it is more usefull, for instance you can check that
            # no flags at all was given with expr
            # {![string match "*-*" $Args]}
            lappend vnamesLst [OptName $item];
            set var [OptValue $item];
        } else {
            set var [OptDefaultValue $item];
        }
        }
    }
    return $vnamesLst
    }


# Check the type of a value
# and emit an error if arg is not of the correct type
# otherwise returns the canonical value of that arg (ie 0/1 for booleans)
proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
#    puts "checking '$arg' against '$type' ($typeArgs)";

    # only types "any", "choice", and numbers can have leading "-"

    switch -exact -- $type {
        int {
            if ![regexp {^(-+)?[0-9]+$} $arg] {
                error "not an integer"
            }
        return $arg;
        }
        float {
            return [expr double($arg)]
        }
    script -
        list {
        # if llength fail : malformed list
            if {[llength $arg]==0} {
        if {[OptIsFlag $arg]} {
            error "no values with leading -"
        }
        }
        return $arg;
        }
        boolean {
        if ![regexp -nocase {^(true|false|0|1)$} $arg] {
        error "non canonic boolean"
            }
        # convert true/false because expr/if is broken with "!,...
        if {$arg} {
        return 1
        } else {
        return 0
        }
        }
        choice {
            if {[lsearch -exact $typeArgs $arg] < 0} {
                error "invalid choice"
            }
        return $arg;
        }
    any {
        return $arg;
    }
    string -
    default {
            if {[OptIsFlag $arg]} {
                error "no values with leading -"
            }
        return $arg
        }
    }
    return neverReached;
}

    # internal utilities

    # returns the number of flags matching the given arg
    # sets the (local) prg counter to the list of matches
    proc OptHits {descName arg} {
        upvar $descName desc;
        set hits 0
        set hitems {}
    set i 1;

    set larg [string tolower $arg];
    set len  [string length $larg];
    set last [expr $len-1];

        foreach item [lrange $desc 1 end] {
            set flag [OptName $item]
        # lets try to match case insensitively
        # (string length ought to be cheap)
        set lflag [string tolower $flag];
        if {$len == [string length $lflag]} {
        if {[string compare $larg $lflag]==0} {
            # Exact match case
            OptSetPrgCounter desc $i;
            return 1;
        }
        } else {
        if {[string compare $larg [string range $lflag 0 $last]]==0} {
            lappend hitems $i;
            incr hits;
        }
            }
        incr i;
        }
    if {$hits} {
        OptSetPrgCounter desc $hitems;
    }
        return $hits
    }

    # Extract fields from the list structure:

    proc OptName {item} {
        lindex $item 1;
    }
    #
    proc OptHasBeenSet {item} {
    Lget $item {2 0};
    }
    #
    proc OptValue {item} {
    Lget $item {2 1};
    }

    proc OptIsFlag {name} {
        string match "-*" $name;
    }
    proc OptIsOpt {name} {
        string match {\?*} $name;
    }
    proc OptVarName {item} {
        set name [OptName $item];
        if {[OptIsFlag $name]} {
            return [string range $name 1 end];
        } elseif {[OptIsOpt $name]} {
        return [string trim $name "?"];
    } else {
            return $name;
        }
    }
    proc OptType {item} {
        lindex $item 3
    }
    proc OptTypeArgs {item} {
        lindex $item 4
    }
    proc OptHelp {item} {
        lindex $item 5
    }
    proc OptNeedValue {item} {
        string compare [OptType $item] boolflag
    }
    proc OptDefaultValue {item} {
        set val [OptTypeArgs $item]
        switch -exact -- [OptType $item] {
            choice {return [lindex $val 0]}
        boolean -
        boolflag {
        # convert back false/true to 0/1 because expr !$bool
        # is broken..
        if {$val} {
            return 1
        } else {
            return 0
        }
        }
        }
        return $val
    }

    # Description format error helper
    proc OptOptUsage {item {what ""}} {
        return -code error "invalid description format$what: $item\n\
                should be a list of {varname|-flagname ?-type? ?defaultvalue?\
                ?helpstring?}";
    }


    # Generate a canonical form single instruction
    proc OptNewInst {state varname type typeArgs help} {
    list $state $varname [list 0 {}] $type $typeArgs $help;
    #                          ^  ^
    #                          |  |
    #               hasBeenSet=+  +=currentValue
    }

    # Translate one item to canonical form
    proc OptNormalizeOne {item} {
        set lg [Lassign $item varname arg1 arg2 arg3];
#       puts "called optnormalizeone '$item' v=($varname), lg=$lg";
        set isflag [OptIsFlag $varname];
    set isopt  [OptIsOpt  $varname];
        if {$isflag} {
            set state "flags";
        } elseif {$isopt} {
        set state "optValue";
    } elseif {[string compare $varname "args"]} {
        set state "value";
    } else {
        set state "args";
    }

    # apply 'smart' 'fuzzy' logic to try to make
    # description writer's life easy, and our's difficult :
    # let's guess the missing arguments :-)

        switch $lg {
            1 {
                if {$isflag} {
                    return [OptNewInst $state $varname boolflag false ""];
                } else {
                    return [OptNewInst $state $varname any "" ""];
                }
            }
            2 {
                # varname default
                # varname help
                set type [OptGuessType $arg1]
                if {[string compare $type "string"] == 0} {
                    if {$isflag} {
            set type boolflag
            set def false
            } else {
            set type any
            set def ""
            }
            set help $arg1
                } else {
                    set help ""
                    set def $arg1
                }
                return [OptNewInst $state $varname $type $def $help];
            }
            3 {
                # varname type value
                # varname value comment

                if [regexp {^-(.+)$} $arg1 x type] {
            # flags/optValue as they are optional, need a "value",
            # on the contrary, for a variable (non optional),
                # default value is pointless, 'cept for choices :
            if {$isflag || $isopt || ($type == "choice")} {
            return [OptNewInst $state $varname $type $arg2 ""];
            } else {
            return [OptNewInst $state $varname $type "" $arg2];
            }
                } else {
                    return [OptNewInst $state $varname\
                [OptGuessType $arg1] $arg1 $arg2]
                }
            }
            4 {
                if [regexp {^-(.+)$} $arg1 x type] {
            return [OptNewInst $state $varname $type $arg2 $arg3];
                } else {
                    return -code error [OptOptUsage $item];
                }
            }
            default {
                return -code error [OptOptUsage $item];
            }
        }
    }

    # Auto magic lasy type determination
    proc OptGuessType {arg} {
        if [regexp -nocase {^(true|false)$} $arg] {
            return boolean
        }
        if [regexp {^(-+)?[0-9]+$} $arg] {
            return int
        }
        if ![catch {expr double($arg)}] {
            return float
        }
        return string
    }

    # Error messages front ends

    proc OptAmbigous {desc arg} {
        OptError "ambigous option \"$arg\", choose from:" [OptSelection $desc]
    }
    proc OptFlagUsage {desc arg} {
        OptError "bad flag \"$arg\", must be one of" $desc;
    }
    proc OptTooManyArgs {desc arguments} {
        OptError "too many arguments (unexpected argument(s): $arguments),\
        usage:"\
        $desc 1
    }
    proc OptParamType {item} {
    if {[OptIsFlag $item]} {
        return "flag";
    } else {
        return "parameter";
    }
    }
    proc OptBadValue {item arg {err {}}} {
#       puts "bad val err = \"$err\"";
        OptError "bad value \"$arg\" for [OptParamType $item]"\
        [list $item]
    }
    proc OptMissingValue {descriptions} {
#        set item [OptCurDescFinal $descriptions];
        set item [OptCurDesc $descriptions];
        OptError "no value given for [OptParamType $item] \"[OptName $item]\"\
        (use -help for full usage) :"\
        [list $item]
    }

proc ::tcl::OptKeyError {prefix descKey {header 0}} {
    OptError $prefix [OptKeyGetDesc $descKey] $header;
}

    # determine string length for nice tabulated output
    proc OptLengths {desc nlName tlName dlName} {
    upvar $nlName nl;
    upvar $tlName tl;
    upvar $dlName dl;
    foreach item $desc {
        if {[OptIsCounter $item]} continue;
        if {[OptIsPrg $item]} {
        OptLengths $item nl tl dl
        } else {
        SetMax nl [string length [OptName $item]]
        SetMax tl [string length [OptType $item]]
        set dv [OptTypeArgs $item];
        if {[OptState $item] != "header"} {
            set dv "($dv)";
        }
        set l [string length $dv];
        # limit the space allocated to potentially big "choices"
        if {([OptType $item] != "choice") || ($l<=12)} {
            SetMax dl $l
        } else {
            if {![info exists dl]} {
            set dl 0
            }
        }
        }
    }
    }
    # output the tree
    proc OptTree {desc nl tl dl} {
    set res "";
    foreach item $desc {
        if {[OptIsCounter $item]} continue;
        if {[OptIsPrg $item]} {
        append res [OptTree $item $nl $tl $dl];
        } else {
        set dv [OptTypeArgs $item];
        if {[OptState $item] != "header"} {
            set dv "($dv)";
        }
        append res [format "\n    %-*s %-*s %-*s %s" \
            $nl [OptName $item] $tl [OptType $item] \
            $dl $dv [OptHelp $item]]
        }
    }
    return $res;
    }

# Give nice usage string
proc ::tcl::OptError {prefix desc {header 0}} {
    # determine length
    if {$header} {
    # add faked instruction
    set h [list [OptNewInst header Var/FlagName Type Value Help]];
    lappend h   [OptNewInst header ------------ ---- ----- ----];
    lappend h   [OptNewInst header {( -help} "" "" {gives this help )}]
    set desc [concat $h $desc]
    }
    OptLengths $desc nl tl dl
    # actually output
    return "$prefix[OptTree $desc $nl $tl $dl]"
}


################     General Utility functions   #######################

#
# List utility functions
# Naming convention:
#     "Lvarxxx" take the list VARiable name as argument
#     "Lxxxx"   take the list value as argument
#               (which is not costly with Tcl8 objects system
#                as it's still a reference and not a copy of the values)
#

# Is that list empty ?
proc ::tcl::Lempty {list} {
    expr {[llength $list]==0}
}

# Gets the value of one leaf of a lists tree
proc ::tcl::Lget {list indexLst} {
    if {[llength $indexLst] <= 1} {
        return [lindex $list $indexLst];
    }
    Lget [lindex $list [Lfirst $indexLst]] [Lrest $indexLst];
}
# Sets the value of one leaf of a lists tree
# (we use the version that does not create the elements because
#  it would be even slower... needs to be written in C !)
# (nb: there is a non trivial recursive problem with indexes 0,
#  which appear because there is no difference between a list
#  of 1 element and 1 element alone : [list "a"] == "a" while
#  it should be {a} and [listp a] should be 0 while [listp {a b}] would be 1
#  and [listp "a b"] maybe 0. listp does not exist either...)
proc ::tcl::Lvarset {listName indexLst newValue} {
    upvar $listName list;
    if {[llength $indexLst] <= 1} {
        Lvarset1nc list $indexLst $newValue;
    } else {
        set idx [Lfirst $indexLst];
        set targetList [lindex $list $idx];
        # reduce refcount on targetList (not really usefull now,
    # could be with optimizing compiler)
#        Lvarset1 list $idx {};
        # recursively replace in targetList
        Lvarset targetList [Lrest $indexLst] $newValue;
        # put updated sub list back in the tree
        Lvarset1nc list $idx $targetList;
    }
}
# Set one cell to a value, eventually create all the needed elements
# (on level-1 of lists)
variable emptyList {}
proc ::tcl::Lvarset1 {listName index newValue} {
    upvar $listName list;
    if {$index < 0} {return -code error "invalid negative index"}
    set lg [llength $list];
    if {$index >= $lg} {
        variable emptyList;
        for {set i $lg} {$i<$index} {incr i} {
            lappend list $emptyList;
        }
        lappend list $newValue;
    } else {
        set list [lreplace $list $index $index $newValue];
    }
}
# same as Lvarset1 but no bound checking / creation
proc ::tcl::Lvarset1nc {listName index newValue} {
    upvar $listName list;
    set list [lreplace $list $index $index $newValue];
}
# Increments the value of one leaf of a lists tree
# (which must exists)
proc ::tcl::Lvarincr {listName indexLst {howMuch 1}} {
    upvar $listName list;
    if {[llength $indexLst] <= 1} {
        Lvarincr1 list $indexLst $howMuch;
    } else {
        set idx [Lfirst $indexLst];
        set targetList [lindex $list $idx];
        # reduce refcount on targetList
        Lvarset1nc list $idx {};
        # recursively replace in targetList
        Lvarincr targetList [Lrest $indexLst] $howMuch;
        # put updated sub list back in the tree
        Lvarset1nc list $idx $targetList;
    }
}
# Increments the value of one cell of a list
proc ::tcl::Lvarincr1 {listName index {howMuch 1}} {
    upvar $listName list;
    set newValue [expr [lindex $list $index]+$howMuch];
    set list [lreplace $list $index $index $newValue];
    return $newValue;
}
# Returns the first element of a list
proc ::tcl::Lfirst {list} {
    lindex $list 0
}
# Returns the rest of the list minus first element
proc ::tcl::Lrest {list} {
    lrange $list 1 end
}
# Removes the first element of a list
proc ::tcl::Lvarpop {listName} {
    upvar $listName list;
    set list [lrange $list 1 end];
}
# Same but returns the removed element
proc ::tcl::Lvarpop2 {listName} {
    upvar $listName list;
    set el [Lfirst $list];
    set list [lrange $list 1 end];
    return $el;
}
# Assign list elements to variables and return the length of the list
proc ::tcl::Lassign {list args} {
    # faster than direct blown foreach (which does not byte compile)
    set i 0;
    set lg [llength $list];
    foreach vname $args {
        if {$i>=$lg} break
        uplevel [list set $vname [lindex $list $i]];
        incr i;
    }
    return $lg;
}

# Misc utilities

# Set the varname to value if value is greater than varname's current value
# or if varname is undefined
proc ::tcl::SetMax {varname value} {
    upvar 1 $varname var
    if {![info exists var] || $value > $var} {
        set var $value
    }
}

# Set the varname to value if value is smaller than varname's current value
# or if varname is undefined
proc ::tcl::SetMin {varname value} {
    upvar 1 $varname var
    if {![info exists var] || $value < $var} {
        set var $value
    }
}


    # everything loaded fine, lets create the test proc:
    OptCreateTestProc
    # Don't need the create temp proc anymore:
    rename OptCreateTestProc {}
}